Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue24/classtrp/OBJTRAPS.PAS

Pascal/Delphi Source File | 1997-06-02 | 18.6 KB | 549 lines

//&-& fil: unit ObjTraps (c) 1997 Cyril Jandia /////////////////////////////////
//
//&-& des: &&unit ObjTraps
//&-& use: &&debug &&general
//&-& iou: &&people D.Lantim C.Calvert &&org ETT
//&-& bor: &&D2 &&D3 &&BCB1
//
//&-& cur: 0.3
//&-& cur: (05/24/1997) testing w/ Delphi 3;
//
//&-& aim: unit to trap object creation/destruction
//
//
// Abstract
// --------
// This small quick'n dirty unit allows us to trap object creation/destruction
// through a kind of "black box" we access via quite a simple interface:
// class TClassTrap.
//
// The way we trap object creation/destruction with this class gives us an
// opportunity to have a reference on our objects even when we would say it is
// "too soon" or "too late". In fact, we can really see this class TClassTrap as
// a rather cheap mean to programmatically "hook" the standard execution path of
// Delphi objects' creation/destruction.
// From a timeline point of view, thus we can consider TClassTrap carries it out
// its job at what is the very beginning (ie. 'begin...' line) of a class
// constructor/destructor's body.
// It is said "cheap" because it requires us *no* assembly coding, and what is
// cool too, *nor* source code of any of the classes we want to trap.
//
//
// Examples
// --------
// For instance, one can have an alternative solution to the problem of finding
// the creation order of controls used by foreign forms/units (no source code).
// Another case is how to get the reference to a particular exception object,
// though we are already into the 'finally... end' part of a
// 'try... finally... end' block (reminder: there, Delphi normally ensures that
// ExceptObject = nil - this is the so-called "too late" case above).
// Plus many other cases where, as said before, there is *not* even one line of
// source code for giving us a single little chance to guess...
// "what order on earth this stupid thing (I have carelessly downloaded tonight
// without any doc) is using for its objects' creation/destruction ?!"
//
//
// Usage basics
// ------------
// MakeTraps()
// -----------
// Our central helper function is MakeTraps(), which takes two arguments.
// First, a list of TClasses we want to trap at instance creation/destruction;
// for interface simplicity this list is merely an open 'const array of TClass'.
// Second, what is called a "trap-procedure" of type TTrapProc; see below.
//
// Then, for each TClass that appeared in the first actual parameter of call,
// a new TClassTrap has been built to be internally handled by the unit later.
// The role of TClassTrap objects is to "bind" a TClass value, say 'C', to the
// trap-procedure in order to get the latter called each time an instance of
// class 'C' is created and, later, destroyed.
// A short for this scheme could be - well, has been chosen - "class-trap(s)".
// Note all the class-traps that a call to MakeTraps() has successfully made
// for some TClasses will be effective as soon as MakeTraps() returns.
// The reason for this is TClassTrap installs hooks for a TClass's constructor /
// destructor rather soon itself, since it is done in TClassTrap's own Create.
//
// Problems with MakeTraps()
// -------------------------
// Although MakeTraps() "does its best" to trap the classes listed as the first
// argument, there are cases where all TClassTrap's will not be actually built.
// We can be notified of such cases by examining its result (of type Integer):
// if it is less than the number of elements of the first argument we passed in,
// then there was a problem with some elements of the list.
// Therefore, those classes will *not* be trapped by our scheme.
// Some details about this are in "Note on MakeTraps() calls" below.
//
// TrapCount() and TrapOf()
// ------------------------
// 'TrapCount: Integer'  and  'TrapOf(TClass): TClassTrap' are two helper func-
// tions we can use to know, resp., how many class-traps have been successfully
// built until now and which TClassTrap object traps a particular TClass value
// (or nil if none does so).
//
// Features of TClassTrap
// ----------------------
// TClassTrap has four main properties we will want to use, one of which is
// read/write while others are read-only:
// Trapped: TClass -- the class for which the class-trap has been made - r/o;
// TrapProc: TTrapProc -- the trap-procedure for Trapped class - r/w;
// Count: Integer -- nb of accessible objects of Trapped class - r/o;
// Objects[I: Integer]: TObject -- accessible objects of Trapped class - r/o;
//
// N1***Note on MakeTraps() calls***
// ---------------------------------
// When we call MakeTraps() we have to keep in mind that:
// - naturally enough, nil values are simply ignored along the first argument;
// - a class-trap can be set up for any class, except for TClassTrap itself -
//   this is *not* really an implementation issue: merely a choice
//   made to avoid "tricky" calls to MakeTraps(), anyway useless I guess;
// - although we can call MakeTraps() several times for some TClass value
//   (or pass same TClass value to MakeTraps() several times in one call), there
//   will be only *one* instance of TClassTrap internally bound to the TClass;
// - the previous remark leads us to the following: if we want to change the
//   TrapProc for a trapped TClass, then we have no other choice than having
//   a reference to its trap, and then to use its read/write property TrapProc.
//
// N2***Note to C++Builder users***
// --------------------------------
// We can use C++Builder's "dcc32 -jph[n]" feature to obtain a C++ header file
// from this unit. However, if we do so we have to cope w/ some C++Builder's
// language specifics to use it appropriately:
// - concerning MakeTraps(), we'll find it slightly less easy to call because of
//   C++ open arrays implementation; its prototype being dcc32-generated as:
//
//   extern int __fastcall MakeTraps(System::TMetaClass* const *Classes,
//     const int Classes_Size, TTrapProc ATrapProc);
//
//  ie. where it's a TClass expected in Object Pascal, we have to use the syntax
//   __classid(<type>) in C++ to have the expected 'TMetaClass*' above.
//   For example:
//   if we want to trap ctors/dtors of Memos and Edits on TForm2 launched by
//   TForm1 (eg. TForm2 in 'Available forms' list), we can code something like:
//
//void __fastcall MyTrapProc(TClassTrap*, TObject* &obj, TObjectOperation op)
//{
//  if(op == ooCreate)
//    ::MessageBox(NULL,
//      Format(
//        "%s.Create trapped !",
//        OPENARRAY( // uh! longer than in Object Pascal...
//          TVarRec,
//          (obj->ClassName())
//        )
//      ).c_str(), "", MB_OK
//    );
//  else
//    ::MessageBox(NULL,
//      Format(
//        "%s's %s.Free trapped !",
//        OPENARRAY(
//          TVarRec,
//          (((TComponent*)obj)->Name, obj->ClassName())
//        )
//      ).c_str(), "", MB_OK
//    );
//}
//
//void __fastcall TForm1::FormCreate(TObject *Sender)
//{
//  TMetaClass* cls[2] = { __classid(TMemo), __classid(TEdit) };
//  MakeTraps(EXISTINGARRAY(cls), MyTrapProc);
//}
//
//void __fastcall TForm1::Button1Click(TObject *Sender)
//{
//  Form2 = new TForm2(this);
//  Form2->ShowModal();
//  delete Form2;
//}
//
// - however, it seems there is no problem with such a code either:
//
//void __fastcall TForm1::FormCreate(TObject *Sender)
//{
//  new TClassTrap(__classid(TMemo), MyTrapProc);
//  new TClassTrap(__classid(TEdit), MyTrapProc);
//  // ... & for an extra:
//  new TClassTrap(__classid(TForm1), MyTrapProc); // funny how it works!...
//  new TClassTrap(__classid(TForm2), MyTrapProc);
//}
//
//   which is a bit longer C++ code to write - choose what you find easier.
//
// Note also for misc. that:
// the var parameter Instance in TTrapProc procedure type does permit to have a
// a TrapProc "returning" nil on instance creation. Who will find this useful ?
// ::MessageBox(NULL,...) calls above are used instead of Dialogs::ShowMessage()
// or Dialogs::MessageDlg() so that we are notified even when Form1 dies.
// There is normally no problem calling Free on a trap made by MakeTraps() or to
// call RemoveTrapOf() for a class the trap of which has been made on the fly by
// TClassTrap.Create(); you will see below I tried to design TClassTrap so that
// we can rely either on its "native" methods or on the unit's helper functions
// the way we find more natural.
//
// Now, just have fun...
//
//
// I want to dedicate this work to the only one who can make me the happiest man
// in this world...
// Toi, Caroline Che'rie, Mon Amour
//
// Cyril Jandia aka FLFan - Eiffel(And Delphi)Fan Forever - 01/15/97

unit ObjTraps;

interface

uses
  SysUtils, Classes;

type
  TObjectOperation = (ooCreate, ooFree); // todo:comment

  TClassTrap = class;

  // call-back function type a class-trap uses for every instance creation and
  // destruction a trapped class will carry out
  TTrapProc = procedure(const Trap: TClassTrap; const Instance: TObject;
    Operation: TObjectOperation);

  // this simple object allows us to "trap" object creation/destruction by using
  // what is called a "trap-procedure"; see property TrapProc below
  TClassTrap = class
  private
    Unusable: Boolean;
    FHunting: Boolean;
    FTrapped: TClass;
    FObjects: TList{of TObject};
    FTrapProc: TTrapProc;
    FOrgNewInst: Pointer;
    FOrgDestroy: Pointer;
    procedure SetMagicHooks(const Hook1, Hook2: Pointer);
    procedure NotifyOfNewInstance(const Instance: TObject);
    procedure NotifyOfDestruction(const Instance: TObject);
    procedure SetTrapProc(const ATrapProc: TTrapProc);
    function GetCount: Integer;
    function GetObjects(const I: Integer): TObject;
  public
    constructor Create(const AClass: TClass);
    constructor CreateTrap(const AClass: TClass; const ATrapProc: TTrapProc);
    destructor Destroy; override;
    // is the trap effective?
    property Hunting: Boolean read FHunting;
    // class for which the class-trap has been made
    property Trapped: TClass read FTrapped;
    // trap-procedure to call on trapped class' instance creation/destruction
    property TrapProc: TTrapProc read FTrapProc write SetTrapProc;
    // nb of accessible objects of trapped class
    property Count: Integer read GetCount;
    // accessible objects of trapped class
    property Objects[const I: Integer]: TObject read GetObjects; default;
  end;

// main function that installs traps for the Classes with the trap-procedure
// pointed to by ATrapProc;
// returns the nb of classes successfully trapped
function MakeTraps(const Classes: array of TClass;
  const ATrapProc: TTrapProc): Integer;

// helper function: returns the number of class-traps currently set up
function TrapCount: Integer;

// helper function: returns the trap set up for a class, if any, or nil if none
function TrapOf(const AClass: TClass): TClassTrap;

// helper procedure: removes the trap that has been set up for a class
procedure RemoveTrapOf(const AClass: TClass);

implementation

uses
  Windows; // hoho! someone needs Win32 down there (just find who...)

type
  PVmt = ^TVmt;
  TVmt = record
{$IFDEF VER100}
    Vmt: Pointer;
    IntfTable: Pointer;
{$ENDIF}
    AutoTable: Pointer;
    InitTable: Pointer;
    TypeInfo: Pointer;
    FieldTable: Pointer;
    MethodTable: Pointer;
    DynMethodTable: Pointer;
    ClassName: PShortString;
    InstanceSize: Cardinal;
    ClassParent: Pointer;
{$IFDEF VER100}
    SafeCallExceptionMethod: Pointer;
{$ENDIF}
    DefaultHandler: Pointer;
    NewInstance: Pointer;
    FreeInstance: Pointer;
    Destroy: Pointer;
  end;

  // serves the magic done by TClassTrap.SetMagicHooks()
  TTrappedObject = class
    class function NewInstance: TObject; override;
    destructor Destroy; override;
  end;

// the class-traps themselves
var
  Traps: TList{of TClassTrap};

function TrapAt(const I: Integer): TClassTrap;
begin
  Result := TClassTrap(Traps[I]);
end;

function GetVmt(const AClass: TClass): PVmt;
begin
  Result := PVmt(AClass); if Result <> nil then Dec(Result);
end;

function MakeTraps(const Classes: array of TClass;
  const ATrapProc: TTrapProc): Integer;
var
  i: Integer;
  trap: TClassTrap;
begin
  Result := 0;
  for i := 0 to High(Classes) do begin
    trap := TClassTrap.CreateTrap(Classes[i], ATrapProc);
    if not trap.Unusable then Inc(Result);
  end;
end;

function TrapCount: Integer;
begin
  Result := Traps.Count;
end;

function TrapOf(const AClass: TClass): TClassTrap;
var
  i: Integer;
  trap: TClassTrap;
begin
  Result := nil;
  for i := 0 to TrapCount - 1 do begin
    trap := TrapAt(i);
    if trap.FTrapped = AClass then begin
      Result := trap;
      Break;
    end;
  end;
end;

procedure RemoveTrapOf(const AClass: TClass);
var
  trap: TClassTrap;
begin
  trap := TrapOf(AClass);
  if trap <> nil then trap.Free;
end;

constructor TClassTrap.Create(const AClass: TClass);
var
  vmt: PVmt;
begin
  if AClass = nil then
    Unusable := True;
  if TrapOf(AClass) <> nil then
    Unusable := True;
  if AClass.InheritsFrom(TClassTrap) then
    Unusable := True;
  vmt := GetVmt(AClass);
  FOrgNewInst := vmt^.NewInstance;
  FOrgDestroy := vmt^.Destroy;
  FTrapped := AClass;
  FObjects := TList.Create;
  FObjects.Capacity := 1024;
  Traps.Add(Self); // take care of updating the unit's trap list
end;

constructor TClassTrap.CreateTrap(const AClass: TClass;
  const ATrapProc: TTrapProc);
begin
  Create(AClass);
  SetTrapProc(ATrapProc);
end;

destructor TClassTrap.Destroy;
var
  i: Integer;
begin
  // restore original NewInstance and Destroy of Trapped class
  SetMagicHooks(FOrgNewInst, FOrgDestroy);
  i := Traps.IndexOf(Self);
  if i >= 0 then Traps.Delete(i); // take care of updating the unit's trap list
  FObjects.Free;
  inherited Destroy;
end;

procedure TClassTrap.NotifyOfNewInstance(const Instance: TObject);
begin
  if Instance <> nil then FObjects.Add(Instance);
  if @FTrapProc <> nil then FTrapProc(Self, Instance, ooCreate);
end;

procedure TClassTrap.NotifyOfDestruction(const Instance: TObject);
var
  i: Integer;
begin
  if @FTrapProc <> nil then FTrapProc(Self, Instance, ooFree);
  i := FObjects.IndexOf(Instance);
  if i >= 0 then FObjects.Delete(i);
end;

procedure TClassTrap.SetTrapProc(const ATrapProc: TTrapProc);
var
  vmt: PVmt;
begin
  if Unusable then Exit;
  FTrapProc := ATrapProc;
  if @FTrapProc = nil then begin
    SetMagicHooks(FOrgNewInst, FOrgDestroy);
    FHunting := False;
  end
  else begin
    if FHunting then Exit;
    vmt := GetVmt(TTrappedObject);
    SetMagicHooks(vmt^.NewInstance, vmt^.Destroy);
    FHunting := True;
  end;
end;

function TClassTrap.GetCount: Integer;
begin
  Result := FObjects.Count;
end;

function TClassTrap.GetObjects(const I: Integer): TObject;
begin
  if (I < 0) or (I >= GetCount) then Result := nil
  else Result := FObjects[i];
end;

procedure TClassTrap.SetMagicHooks(const Hook1, Hook2: Pointer);
var
  vmt: PVmt;
  prot: Longint;
begin
  // the real thing begins
  vmt := GetVmt(FTrapped);

  VirtualProtect(@vmt^.NewInstance,
    SizeOf(Pointer), PAGE_READWRITE, @prot); // let's be brave
  vmt^.NewInstance := Hook1; // let's be yet more brave

  // time to be clean: not necessary but easy to do, then...
  VirtualProtect(@vmt^.NewInstance,
    SizeOf(Pointer), prot, @prot);

  VirtualProtect(@vmt^.Destroy,
    SizeOf(Pointer), PAGE_READWRITE, @prot);
  vmt^.Destroy := Hook2;

  // time to be clean: not necessary but easy to do, then...
  VirtualProtect(@vmt^.Destroy,
    SizeOf(Pointer), prot, @prot);
end;

class function TTrappedObject.NewInstance: TObject;
begin
  // following is a really simple line of code, at first look;
  // well, it works fine in most (hey! all?!) cases - "small is beautiful";
  // note, however, it is *not* obvious at all such a code be appropriate, but
  // a careful look at System.pas reveals us this *is* sufficient here to obtain
  // a fresh instance for almost nothing; ok. it needs further testing, still
  Result := inherited NewInstance; // todo:testing

  TrapOf(Self).NotifyOfNewInstance(Result); // time to do user job
end;

// internal helper function; see below
function OrgDestroyOf(const AClass: TClass): Pointer;
begin
  Result := TrapOf(AClass).FOrgDestroy;
end;

destructor TTrappedObject.Destroy;
begin
  // see comment below in asm block(*)
  TrapOf(Self.ClassType).NotifyOfDestruction(Self); // time to do user job

  // since compiler-generated code for 'inherited Destroy' is not appropriate
  // here for a necessary call to original Destroy of a trapped class, well,
  // we do have to rely on BASM32 for once:
  asm
    // we got Self.ClassType first(*) to know which TClassTrap, and just below
    // which Trapped TClass are on business
    mov eax, [esi]
    // then get original Destroy of trapped class that we have saved thought-
    // fully during TClassTrap's creation
    call OrgDestroyOf
    // then prepare the call address
    mov ecx, eax
    // to which that will be a call via an instance, not via a TClass
    xor edx, edx
    // by the way, bring back this instance
    mov eax, esi
    // and here we go
    call ecx
  end; // at last: one big thanx to BASM32! ;^) ...Ebony doesn't have it yet |-(
end;

// most simple code
initialization
  Traps := TList.Create;
  Traps.Capacity := 1024;
finalization
  while Traps.Count > 0 do TrapAt(0).Free;
  Traps.Free;
end.

//&-& ver: revision history
//
//&-& ver: 0.3
//&-& ver: (05/24/1997) testing w/ Delphi 3;
//
//&-& ver: 0.2a
//&-& ver: (01/23/1997) note to C++Builder users added;
//
//&-& ver: 0.2
//&-& ver: (01/16/1997) unit comment header updated;
//&-& ver: (01/16/1997) procedure RemoveTrapOf() added;
//
//&-& ver: 0.1d
//&-& ver: (01/15/1997) unit comment header added for temporary documentation;
//&-& ver: (01/15/1997) + very first try of gentle acknowledgements...
//
//&-& ver: 0.1c
//&-& ver: (01/14/1997) yet another identifiers/comments refresh;
//
//&-& ver: 0.1b
//&-& ver: (01/13/1997) lonesome bug fixed in TClassTrap.NotifyOfDestruction();
//
//&-& ver: 0.1a
//&-& ver: (01/11/1997) revised implementation comments;
//
//&-& ver: 0.1
//&-& ver: (01/11/1997) code made more robust here & there;
//
//&-& ver: 0.0b
//&-& ver: (01/10/1997) implementation comments added;
//
//&-& ver: 0.0a
//&-& ver: (01/09/1997) revised identifiers;
//&-& ver: (01/09/1997) revision history added;
//
//&-& ver: 0.0
//&-& ver: (01/08/1997) initial version:
//&-& ver: (01/08/1997) from experiments made for the "LiveInspector" project.
//
//&-& end: unit ObjTraps (c) 1997 Cyril Jandia /////////////////////////////////